home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / tpascal.arc / BLIST.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-04-01  |  7.4 KB  |  216 lines
  1. PROGRAM BList;
  2.  
  3. { TURBO PASCAL SOURCE CODE LISTER AND BEGIN-END COUNTER PROGRAM }
  4.  
  5. { Prints a listing to console or printer of a TURBO PASCAL source code with
  6.   optional display of comment counter and begin/end counter, and also optional
  7.   display skip of paper perforations.  Accepts file name passed by CP/M or
  8.   from operator input of file to list. }
  9.  
  10. { This version of the code is specific to CP/M-80 because the GET_IN_FILE
  11.   procedure looks for a parameter passed by CP/M at absolute location $80. The
  12.   procedure could be modified for other operating systems, or not to accept
  13.   passed parameters at all. }
  14.  
  15. { I declare that this code is released to the PUBLIC DOMAIN as of July 1, 1984
  16.                                        Phillip M. Nickell                     }
  17.  
  18. { Modified Sept. 1, 1984 by Marvin Landis
  19.   Record/end combination is now handled correctly. }
  20.  
  21. VAR Buff1: STRING[135];                       { Input line buffer }
  22.     ListFil: TEXT;                            { Fib for LST: or CON: output }
  23.     InFile: TEXT;                             { Fib for input file }
  24.     BCount,KCount,LineCt: INTEGER;            { Counters }
  25.     Count_Be,PerfSkip: BOOLEAN;               { Count begin/end and skip }
  26.  
  27. CONST First: BOOLEAN = TRUE;                  { True when program is run }
  28.  
  29. { To customize code for your printer and desires - adjust the next two items }
  30.  
  31.       MaxLine = 60;      { max # of lines on page when in PERFSKIP mode }
  32.       SkipLine = 2;      { # of lines to skip at top of form }
  33.  
  34.       CR = #13;
  35.       LF = #10;
  36.       FF = #12;
  37.  
  38. Procedure Clean;      { Clears screen and positions cursor }
  39. BEGIN
  40.   ClrScr;
  41.   GoToXY(1,10);
  42. END;
  43.  
  44. Procedure Lines(X: Integer);   { Puts X amount of blank lines to output file }
  45. Var N: Integer;
  46. BEGIN
  47.   For N:= 1 To X Do
  48.     Writeln(ListFil);
  49. END;
  50.  
  51. { GET_IN_FILE PROCEDURE : When program is first run, it will check for a file
  52.   name passed by CP/M and will try to open that file.  If no name is passed,
  53.   it will ask operator for a file name to open.  Proc will tell operator if
  54.   file doesn't exist and will allow multiple retrys.  On second and later
  55.   executions, proc will not check for CP/M passed file name.  In all cases
  56.   proc will assume a file type of .PAS if file type is not specified.  Exit
  57.   from the program occurs when a null string is entered in response to a file
  58.   name request. }
  59.  
  60. Procedure Get_In_File;                 { Gets input file name }
  61. Var FNam: String[14];                  { Input file name }
  62.     Parm: String[14] Absolute $81;     { Passed file name if any }
  63.     ParmLth: Byte Absolute $80;        { CP/M passed length of Parm }
  64.     Existing: Boolean;
  65. BEGIN
  66.   Repeat                               { Until file exists }
  67.     If (ParmLth In [1..14]) And First Then
  68.       FNam:= Copy(Parm,1,ParmLth - 1)
  69.     Else Begin
  70.       Clean;
  71.       Write('Enter file name to list or <CR> to exit: ');
  72.       Readln(FNam);
  73.     End;
  74.     If FNam = '' Then Halt;
  75.     If Pos('.',FNam) = 0 Then
  76.       FNam:= Concat(FNam,'.PAS');      { File default to .PAS type }
  77.     First:= False;
  78.     Assign(InFile,FNam);
  79.     {$I-}
  80.     Reset(InFile);
  81.     {$I+}
  82.     Existing:= (IOResult = 0);
  83.     If Not Existing Then Begin
  84.       Clean;
  85.       Writeln('File does not exist.');
  86.       Delay(700);
  87.     End;
  88.   Until Existing;
  89. END;   { Get_In_File }
  90.  
  91. { GET_OUT_FILE procedure : Asks operator to select output to console device
  92.   or list device, and then assigns and resets a file control block to the
  93.   appropriate device.  'C' or 'P' are the only correct responses, and
  94.   multiple retrys are allowed. }
  95.  
  96. Procedure Get_Out_File;
  97. Var C: Char;
  98. BEGIN
  99.   Repeat                            { Until good selection }
  100.     Clean;
  101.     Write('Output listing to (C)onsole or (P)rinter? ');
  102.     C:= UpCase(Chr(BDos(1)));
  103.   Until C In ['C','P'];
  104.   Writeln;
  105.   If C = 'C' Then
  106.     Assign(ListFil,'CON:')
  107.   Else
  108.     Assign(ListFil,'LST:');
  109.   Reset(ListFil);
  110. END;  { Get_Out_File }
  111.  
  112. { GET_OPTIONS procedure : Asks operator if count of begin/end pairs is desired,
  113.   and also if skip over paper perforations is desired.  Proc will set or clear
  114.   the Count_Be flag and the PerfSkip flag. }
  115.  
  116. Procedure Get_Options;
  117. Var C: Char;
  118. BEGIN
  119.   Repeat
  120.     Clean;
  121.     Write('Count of BEGIN/END pairs (Y/N)? ');
  122.     C:= UpCase(CHR(BDOS(1)));
  123.   Until C In ['Y','N'];
  124.   If C = 'Y' Then Count_Be:= True
  125.   Else Count_Be:= False;
  126.   Repeat
  127.     Clean;
  128.     Write('Skip printer perforations (Y/N)? ');
  129.     C:= UpCase(Chr(BDOS(1)));
  130.   Until C In ['Y','N'];
  131.   If C = 'Y' Then PerfSkip:= True
  132.   Else PerfSkip:= False;
  133. END;  { Get_Options }
  134.  
  135. { SCAN_LINE procedure : Scans one line of Turbo Pascal source code looking
  136.   for begin/end pairs, case/end pairs, literal fields and comment fields.
  137.   BCount is begin/end and case/end counter.  KCount is comment counter.
  138.   Begin/case/ends are only valid outside of comment fields and literal
  139.   constant fields (KCount = 0 and NOT LITERAL).  Some of the code in this
  140.   procedure appears at first glance to be repetitive and/or redundant, but
  141.   was added to speed up the process of scanning each line of source code.
  142.   The program now spits out listings much faster than a 160 cps printer. }
  143.  
  144. Procedure Scan_Line;
  145. Var Literal: Boolean;               { True if in literal field }
  146.     Tmp: String[8];                 { Temp work area }
  147.     Buff2: String[135];             { Working line buffer }
  148.     I: Integer;
  149. BEGIN
  150.   Literal:= False;
  151.   Buff2[0]:= Buff1[0];      { Copy input buffer into working buffer }
  152.   For I:= 1 to Length(Buff1) Do
  153.     Buff2[I]:= UpCase(Buff1[I]);
  154.   Buff2:= Concat(' ',Buff2,'       ');   { Add on some working space }
  155.   For I:= 1 to Length(Buff2) - 7 Do Begin
  156.     Tmp:= Copy(Buff2,I,8);
  157.     If Not Literal Then Begin
  158.       If Tmp[1] In ['{','}','(','*'] Then Begin
  159.         If (Tmp[1] = '{') Or (Copy(Tmp,1,2) = '(*') Then
  160.           KCount:= Succ(KCount);
  161.         If (Tmp[1] = '}') Or (Copy(Tmp,1,2) = '*)') then
  162.           KCount:= Pred(KCount);
  163.       End;
  164.     End;
  165.     If KCount = 0 Then Begin
  166.       If Tmp[1] = Chr(39) Then Literal:= Not Literal;
  167.       If Not Literal And (Tmp[2] In ['B','C','E','R']) Then Begin
  168.         If (Copy(Tmp,1,7) = ' BEGIN ') Or (Copy(Tmp,1,6) = ' CASE ') Or
  169.         (Tmp = ' RECORD ') Then Begin
  170.           BCount:= Succ(BCount);
  171.           I:= I + 5;
  172.         End;
  173.         If (Copy(Tmp,1,4) = ' END') And (Tmp[5] In ['.',' ',';']) Then Begin
  174.           BCount:= Pred(BCount);
  175.           I:= I + 4;
  176.         End;
  177.       End;
  178.     End;
  179.   End;
  180. END;  { Scan_Line }
  181.  
  182. BEGIN
  183.   Repeat                     { Forever }
  184.     Get_In_File;
  185.     Get_Out_File;
  186.     Get_Options;
  187.     Lines(1);
  188.     Linect:= 1;
  189.     If Count_Be Then Begin
  190.       KCount:= 0;
  191.       BCount:= 0;
  192.       Writeln(ListFil,' C  B');
  193.     End;
  194.     While Not EOF(InFile) Do Begin
  195.       Readln(InFile,Buff1);
  196.       If Count_Be Then Begin
  197.         Scan_Line;
  198.         Writeln(ListFil,KCount:2,BCount:3,'  ',Buff1);
  199.       End Else
  200.         Writeln(ListFil,Buff1);
  201.       If PerfSkip Then Begin
  202.         LineCt:= Succ(LineCt);
  203.         If LineCt > MaxLine Then Begin
  204.           Write(ListFil,FF);
  205.           Lines(SkipLine);
  206.           LineCt:= 1;
  207.           If Count_Be Then Writeln(ListFil,' C  B');
  208.         End;
  209.       End;
  210.     End;
  211.     Write(CR,LF,'Hit any key to continue...');
  212.     BCount:= BDOS(1);
  213.   Until False;     { Exit is in Get_In_File procedure }
  214. END.
  215.  
  216.